home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gwu / gmisc.c < prev    next >
C/C++ Source or Header  |  1996-01-30  |  22KB  |  925 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9. /* gmisc - translation of setl misc.c */
  10.  
  11. #define GEN
  12.  
  13. #include "hdr.h"
  14. #include "vars.h"
  15. #include "segment.h"
  16. #include "gvars.h"
  17. #include "ops.h"
  18. #include "slot.h"
  19. #include "dbxp.h"
  20. #include "exprp.h"
  21. #include "setp.h"
  22. #include "genp.h"
  23. #include "gmainp.h"
  24. #include "segmentp.h"
  25. #include "arithp.h"
  26. #include "libp.h"
  27. #include "gutilp.h"
  28. #include "initp.h"
  29. #include "miscp.h"
  30. #include "smiscp.h"
  31. #include "gmiscp.h"
  32.  
  33. static void relay_set_add(Symbol);
  34. static int in_slot_map(Tuple, Symbol);
  35. static Tuple labelmap_def(Symbol);
  36.  
  37. extern Segment    CODE_SEGMENT, DATA_SEGMENT, DATA_SEGMENT_MAIN;
  38.  
  39. unsigned int subprog_patch_get(Symbol sym)                /*;subprog_patch_get*/
  40. {
  41.     int    i, n;
  42.  
  43.     /* search tuple SUBPROG_PATCH for symbol, return*/
  44.     n = tup_size(SUBPROG_PATCH);
  45.     for (i = 1; i <= n; i += 2) {
  46.         if ((Symbol) SUBPROG_PATCH[i] == sym)
  47.             return (unsigned int) SUBPROG_PATCH[i+1];
  48.     }
  49.     return 0; /* is this right or should there be error return?*/
  50. }
  51.  
  52. void subprog_patch_put(Symbol sym, int off)            /*;subprog_patch_put*/
  53. {
  54.     int    i, n;
  55.  
  56.     n = tup_size(SUBPROG_PATCH);
  57.     for (i = 1; i <= n; i += 2) {
  58.         if ((Symbol) SUBPROG_PATCH[i] == sym ) {
  59.             SUBPROG_PATCH[i+1] = (char *) off;
  60.             return;
  61.         }
  62.     }
  63.     /* here if need new element */
  64.     SUBPROG_PATCH = tup_exp(SUBPROG_PATCH, n+2);
  65.     SUBPROG_PATCH[n+1] = (char *) sym;
  66.     SUBPROG_PATCH[n+2] = (char *) off;
  67.     /* SUBPROG_PATCH is map as tuple: domain elements are symbols, vales
  68.      * are integers
  69.      */
  70. }
  71.  
  72. void subprog_patch_undef(Symbol sym)        /*;subprog_patch_undef*/
  73. {
  74.     int i, n, j;
  75.     n = tup_size(SUBPROG_PATCH);
  76.     for (i = 1; i <= n; i += 2) {
  77.         if ((Symbol) SUBPROG_PATCH[i] == sym) {
  78.             for (j = i+2; j <= n; j++) 
  79.                 SUBPROG_PATCH[j-2] = SUBPROG_PATCH[j];
  80.             SUBPROG_PATCH[0] = (char *) n-2; /* adjust size */
  81.             break;
  82.         }
  83.     }
  84. }
  85.  
  86. /* Miscelleanous utilities on types */
  87.  
  88. Symbol base_type(Symbol name)                /*;base_type*/
  89. {
  90.     /*
  91.      * The base-type of a type-mark is itself, unless the type-mark denotes
  92.      * a subtype.
  93.      */
  94.  
  95.     while (NATURE(name) == na_subtype && TYPE_OF(name) != name)
  96.         name = TYPE_OF(name);
  97.     return name;
  98. }
  99.  
  100. int is_discrete_type(Symbol name)                        /*;is_discrete_type*/
  101. {
  102.     Symbol    btype;
  103.  
  104.     if (cdebug2 > 3)
  105.         TO_ERRFILE("AT PROC :  is_discrete_type") ;
  106.  
  107.     if (TYPE_OF(name) != (Symbol)0) btype = root_type(name);
  108.     else return FALSE;
  109.     if (btype == symbol_integer
  110.       || btype == symbol_universal_integer
  111.       || btype == symbol_discrete_type
  112.       || btype == symbol_any) return TRUE;
  113.     if (NATURE(btype) == na_enum ) return TRUE;
  114.     return FALSE;
  115. }
  116.  
  117. int is_unconstrained(Symbol typ)                        /*;is_unconstrained*/
  118. {
  119.     Symbol    parent_type;
  120.  
  121.     switch( NATURE(typ)) {
  122.     case(na_array):
  123.         return TRUE;
  124.     case(na_record):
  125.         return has_discriminant(typ);
  126.     case(na_type):
  127.         parent_type = TYPE_OF(typ);
  128.         if (parent_type == typ)
  129.             return FALSE;
  130.         else
  131.             return is_unconstrained(parent_type);
  132.     default:
  133.         return FALSE;
  134.     }
  135. }
  136.  
  137. int not_included(Symbol small_type, Symbol large_type)        /*;not_included*/
  138. {
  139.     /*
  140.      * Checks if the bounds of small_type are (statically) out of those of
  141.      * large_type.
  142.      */
  143.  
  144.     Node    small_low_def, small_high_def, large_low_def, large_high_def;
  145.     Tuple    tup;
  146.     Const    small_low, small_high, large_low, large_high;
  147.  
  148.     if (large_type == base_type(small_type))
  149.         return FALSE;     /* even if not static in that case */
  150.  
  151.     tup = SIGNATURE(small_type);
  152.     small_low_def = (Node) tup[2];
  153.     small_high_def = (Node) tup[3];
  154.     tup = SIGNATURE(large_type);
  155.     large_low_def = (Node) tup[2];
  156.     large_high_def = (Node) tup[3];
  157.     small_low = get_ivalue(small_low_def);
  158.     small_high = get_ivalue(small_high_def);
  159.     large_low = get_ivalue(large_low_def);
  160.     large_high = get_ivalue(large_high_def);
  161.     if (small_low->const_kind == CONST_OM
  162.       || small_high->const_kind == CONST_OM
  163.       || large_low->const_kind == CONST_OM
  164.       || large_high->const_kind == CONST_OM) {
  165.         return TRUE;
  166.     }
  167.     else if (is_fixed_type(large_type) || is_float_type(large_type)) {
  168.         return const_lt(small_low, small_high)
  169.           && (const_lt(small_low, large_low)
  170.           || const_gt(small_high, large_high));
  171.     }
  172.     else {
  173.         return const_lt(small_low , small_high)
  174.           && (const_lt(small_low , large_low)
  175.           || const_gt(small_high , large_high));
  176.     }
  177. }
  178.  
  179. #ifndef BINDER
  180. void optional_qual(Symbol source_type, Symbol target_type)    /*;optional_qual*/
  181. {
  182.     Symbol    source_obj_type, target_obj_type;
  183.  
  184.     /* Generates a qual if necessary. The value is already on top of stack. */
  185.     if (target_type == base_type(source_type))
  186.         ;    /* qual never necessary here */
  187.     else if (is_access_type(target_type)) {
  188.         source_obj_type = (Symbol) designated_type(source_type);
  189.         target_obj_type = (Symbol) designated_type(target_type);
  190.         if (target_obj_type != source_obj_type 
  191.           && target_obj_type != base_type(source_obj_type)) {
  192.             if (is_array_type(target_obj_type)) {
  193.                 gen_access_qual(as_qual_index, target_obj_type);
  194.             }
  195.             else if (is_record_type(target_obj_type)) {
  196.                 gen_access_qual(as_qual_discr, target_obj_type);
  197.             }
  198.             else {     /* simple type */
  199.                 ;  /* No need to qual range */
  200.             }
  201.         }
  202.  
  203.     }
  204.     else if (is_simple_type(target_type) &&
  205.         not_included(source_type, target_type)) {
  206.         gen_s(I_QUAL_RANGE, target_type);
  207.     }
  208. }
  209. #endif
  210.  
  211. int kind_of(Symbol type_name)                                    /*;kind_of*/
  212. {
  213.     /*
  214.      * Determines the memory unit addressing mode for the given type.
  215.      * NOTE: This procedure is the point where the code generator bombs whenever
  216.      *     there is something wrong with a type declaration....
  217.      */
  218.  
  219.     int        nat, tsiz;
  220.  
  221.     type_name = root_type(type_name);
  222.  
  223. #ifdef TRACE
  224.     if (debug_flag)
  225.         gen_trace_symbol("KIND_OF", type_name);
  226. #endif
  227.  
  228.     nat = NATURE(type_name);
  229.     if (nat == na_array) {
  230.         return mu_dble;
  231.     }
  232.     else if (nat == na_record || nat == na_access) {
  233.         return mu_addr;
  234.     }
  235.     else if (nat == na_package) {
  236.         return mu_byte;
  237.     }
  238.     else if (nat == na_enum) {
  239.         return mu_word;
  240.     }
  241.     else {
  242.         tsiz = TYPE_KIND(type_name);
  243.         if (tsiz == TK_BYTE) {
  244.             return mu_byte;
  245.         }
  246.         else if (tsiz == TK_WORD) {
  247.             return mu_word;
  248.         }
  249.         else if (tsiz == TK_ADDR){
  250.             return mu_addr;
  251.         }
  252.         else if (tsiz == TK_LONG) {
  253.             return mu_long;
  254.         }
  255.         else if (tsiz == TK_XLNG) {
  256.             return mu_xlng;
  257.         }
  258.         else {
  259.             compiler_error_s("Kind_of returning omega. Type name is ",
  260.               type_name);
  261.             return mu_word; /* mu_word bogus value so can proceed */
  262.         }
  263.     }
  264. }
  265.  
  266. int length_of(Symbol type_name)                        /*;length_of*/
  267. {
  268.     /* gives the number of item in the type, assumed to be a discrete type */
  269.  
  270.     Node    low, high;
  271.     Tuple    tup;
  272.     Const    low_const, high_const;
  273.     int         bs, bi;
  274.     tup = SIGNATURE(type_name);
  275.     low = (Node) tup[2];
  276.     high = (Node) tup[3];
  277.  
  278.     low_const = get_ivalue(low);
  279.     high_const = get_ivalue(high);
  280.     if    (low_const->const_kind != CONST_OM
  281.       && high_const->const_kind != CONST_OM) {
  282.         /*   return  get_ivalue_int(high)-get_ivalue_int(low)+1; */
  283.         bi = get_ivalue_int (low);
  284.         bs = get_ivalue_int (high);
  285.         if (bi > bs)
  286.             return 0;
  287.         else
  288.             return bs - bi + 1;
  289.     }
  290.     else {
  291.         return -1;
  292.     }
  293. }
  294.  
  295. /* On symbol table */
  296.  
  297. void new_symbol(Symbol new_name, int new_nature, Symbol new_type,
  298.   Tuple new_signature, Symbol new_alias)                /*;new_symbol*/
  299. {
  300.     NATURE(new_name)    = new_nature;
  301.     TYPE_OF(new_name)    = new_type;
  302.     SIGNATURE(new_name) = new_signature;
  303.     ALIAS(new_name)    = new_alias;
  304. }
  305.  
  306. /* On addresses */
  307.  
  308. void reference_of(Symbol name)                            /*;reference_of*/
  309. {
  310.     /* The C version returns result in two globals; ref_seg?? and ref_off ?? */
  311.  
  312.     int    lrmval;
  313.  
  314. #ifdef SKIP
  315.     REFERENCE_OFFSET = 0; 
  316.     REFERENCE_SEGMENT = 0; /* for initial checkout*/
  317.     return;
  318. #endif
  319.  
  320.     if (tup_mem((char *) name , PARAMETER_SET)) {
  321.         if (!tup_mem((char *) PC(), CODE_PATCH_SET)) {
  322.             CODE_PATCH_SET = tup_with(CODE_PATCH_SET, (char *)PC());
  323.         }
  324.         /* Parameters always referenced */
  325.         /* from assemble, peep-hole OK. */
  326.         REFERENCE_SEGMENT = 0;
  327.         REFERENCE_OFFSET = local_reference_map_get(name);
  328.     }
  329.     else if (local_reference_map_defined(name)) {
  330.         REFERENCE_SEGMENT = 0;
  331.         REFERENCE_OFFSET = local_reference_map_get(name);
  332.     }
  333.     else if (S_SEGMENT(name) != -1) {
  334.         REFERENCE_SEGMENT = S_SEGMENT(name);
  335.         REFERENCE_OFFSET = S_OFFSET(name);
  336.     }
  337.     else {
  338.         lrmval  =  mu_size(mu_addr) * tup_size(RELAY_SET);
  339.         local_reference_map_put(name, lrmval);
  340.         relay_set_add(name);
  341.         REFERENCE_SEGMENT  = 0;
  342.         REFERENCE_OFFSET = lrmval;
  343.     }
  344. }
  345.  
  346. static void relay_set_add(Symbol name)                    /*;relay_set_add*/
  347. {
  348.     if (!tup_mem((char *) name, RELAY_SET))
  349.         RELAY_SET = tup_with(RELAY_SET, (char *) name);
  350. }
  351.  
  352. int is_defined(Symbol name)                                    /*;is_defined*/
  353. {
  354.     if (!local_reference_map_defined(name)) {
  355.         if (S_SEGMENT(name) == -1)
  356.             return FALSE;
  357.     }
  358.     return TRUE;
  359. }
  360.  
  361. /* next_local_reference and next_global_reference in util.c */
  362.  
  363. Symbol get_constant_name(Segment item)                    /*;get_constant_name*/
  364. {
  365.     /* CONSTANT_MAP is used to detect duplicate instances of constant
  366.      * For now we disable this check and always generate new reference
  367.      */
  368.  
  369.     Symbol    name;
  370.  
  371. #ifdef TBSN
  372.     if (NO(name :
  373.     == CONSTANT_MAP(item))) {
  374.         name = new_unique_name("constant");
  375.         next_global_reference_segment(name, item);
  376.         CONSTANT_MAP(item) = name;
  377.     }
  378.     return name;
  379. #endif
  380.     name = new_unique_name("constant");
  381.     next_global_reference_segment(name, item);
  382.     return name;
  383. }
  384.  
  385. void assign_same_reference(Symbol new_name, Symbol old_name)
  386.                                                     /*;assign_same_reference*/
  387. {
  388.     if (tup_mem((char *)old_name , PARAMETER_SET)) {
  389.         PARAMETER_SET    = tup_with(PARAMETER_SET, (char *) new_name);
  390.         ASSOCIATED_SYMBOLS(new_name) = ASSOCIATED_SYMBOLS(old_name);
  391.         local_reference_map_put(new_name, local_reference_map_get(old_name));
  392.     }
  393.     else if (local_reference_map_defined(old_name)) {
  394.         local_reference_map_put(new_name, local_reference_map_get(old_name));
  395.     }
  396.     else if (S_SEGMENT(old_name) != -1) {
  397.         S_SEGMENT(new_name) = S_SEGMENT(old_name);
  398.         S_OFFSET(new_name) = S_OFFSET(old_name);
  399.     }
  400.     else {
  401.         local_reference_map_put(old_name,  mu_size(mu_addr)
  402.             * tup_size(RELAY_SET));
  403.         relay_set_add(old_name);
  404.         local_reference_map_put(new_name, local_reference_map_get(old_name));
  405.     }
  406. }
  407.  
  408. /* Slots management */
  409.  
  410. int select_entry(int a_map_code , Symbol an_item, int a_map_name)
  411.                                                             /*;select_entry*/
  412. {
  413.     /*
  414.      * finds the entry corresponding to an_item into the slot map a_map.
  415.      * creates it if not found, and updates OWNED_SLOTS.
  416.      */
  417.  
  418.     int indx, isin, nmap, j;
  419.     Tuple    a_map;
  420.     Tuple    utup, stup;
  421.     Slot        slot;
  422.  
  423.     switch (a_map_code) {
  424.     case SELECT_CODE: 
  425.         a_map = CODE_SLOTS; 
  426.         break;
  427.     case SELECT_DATA: 
  428.         a_map = DATA_SLOTS; 
  429.         break;
  430.     case SELECT_EXCEPTIONS: 
  431.         a_map = EXCEPTION_SLOTS; 
  432.         break;
  433.     default:
  434. #ifdef DEBUG
  435.         printf("a_map_code: %d\n", a_map_code);
  436. #endif
  437.         chaos("select entry bad a_map_code");
  438.     }
  439.     indx = in_slot_map(a_map, an_item);
  440.     if (indx != 0) {
  441.         ;
  442.     }
  443.     else if (a_map_name == SLOTS_DATA_BORROWED 
  444.       || a_map_name == SLOTS_CODE_BORROWED) {
  445. #ifdef ERRMSG
  446.         compiler_error(a_map_name +' slot not present for '+ str an_item);
  447. #endif
  448.         compiler_error("select_entry: slot not present ");
  449.         return 0;
  450.     }
  451.     else {
  452.         nmap  = tup_size(a_map);
  453.         for (indx = init_slots(a_map_name);;) {
  454.             indx += 1;
  455.             isin = FALSE;
  456.             for (j = 1; j <= nmap; j++) {
  457.                 slot = (Slot) a_map[j];
  458.                 if (slot->slot_number == indx) {
  459.                     isin = TRUE;
  460.                     break;
  461.                 }
  462.             }
  463.             if (isin == FALSE) break;
  464.         }
  465.  
  466.         slot = slot_new(an_item, indx);
  467.         a_map  = tup_with(a_map, (char *)slot);
  468.         switch (a_map_code) {
  469.         case SELECT_CODE: 
  470.             CODE_SLOTS = a_map; 
  471.             break;
  472.         case SELECT_DATA: 
  473.             DATA_SLOTS = a_map; 
  474.             break;
  475.         case SELECT_EXCEPTIONS: 
  476.             EXCEPTION_SLOTS = a_map; 
  477.             break;
  478.         }
  479.  
  480.         if (indx > max_index(a_map_name)) {
  481.             if (a_map_name == SLOTS_DATA) {
  482.                 compiler_error("Too many compilation units");
  483.             }
  484.             else if(a_map_name == SLOTS_CODE) {
  485.                 compiler_error("Too many program units");
  486.             }
  487.             else if (a_map_name == SLOTS_EXCEPTION) {
  488.                 compiler_error("Too many exceptions");
  489.             }
  490.             return 0;
  491.         }
  492.     }
  493.  
  494.     /* In case of a recompilation of an unit, OWNED_SLOTS may not be */
  495.     /* initialized even if index was found in the map. */
  496.     utup = unit_slots_get(unit_number_now);
  497.     stup = (Tuple) utup[a_map_name];
  498.     stup = tup_with(stup, (char *) indx);
  499.     utup[a_map_name] = (char *) stup;
  500.     unit_slots_put(unit_number_now, utup);
  501.  
  502.     return indx;
  503. }
  504.  
  505. static int in_slot_map(Tuple tup, Symbol item)                /*;in_slot_map*/
  506. {
  507.     int        i, n;
  508.     int        seq, unt;
  509.     Slot    s;
  510.  
  511.     n = tup_size(tup);
  512.     unt = S_UNIT(item); 
  513.     seq = S_SEQ(item);
  514.     for (i = 1; i <= n; i++) {
  515.         s = (Slot) tup[i];
  516.         if (unt == s->slot_unit && seq == s->slot_seq)
  517.             return s->slot_number;
  518.     }
  519.     return 0;
  520. }
  521.  
  522. /* Code selection */
  523.  
  524. void optional_deref(Symbol type_name)                    /*;optional_deref*/
  525. {
  526.     if (is_simple_type(type_name))
  527.         gen_k(I_DEREF, kind_of(type_name));
  528. }
  529.  
  530. /* On ivalues */
  531.  
  532. Const get_ivalue(Node node)                                    /*;get_ivalue*/
  533. {
  534.     /*
  535.      * returns a scalar ivalue extracted from the expression.
  536.      * In the case of a rational ivalue, returns the rational representation.
  537.      * In the case of a real ivalue, returns the integer representation
  538.      */
  539.  
  540.     Const    v;
  541.     if (! is_ivalue(node))
  542.         return const_new(CONST_OM);
  543.     v = (Const) N_VAL(node);
  544.     return v;
  545. }
  546.  
  547. int get_ivalue_int(Node node)                                /*;get_ivalue_int*/
  548. {
  549.     /*
  550.      * returns a scalar ivalue extracted from the expression.
  551.      * The ivalue must be  one of the following:
  552.      * 1) integer
  553.      * 2) universal integer that can be converted to integer.
  554.      * Otherwise, chaos is noted.
  555.      * This is used when we suspect an int is always wanted and
  556.      * want to raise an error if this is not the case.
  557.      */
  558.  
  559.     Const    v;
  560.     int n;
  561.     if (! is_ivalue(node)  )
  562.         chaos("get_ivalue_int: arg not ivalue");
  563.     v = (Const) N_VAL(node);
  564.     n = get_const_int(v);
  565.     return n;
  566. }
  567.  
  568. int get_const_int(Const v)                            /*;get_const_int*/
  569. {
  570.     int n = 0;
  571.  
  572.     /* return value of const if integer, chaos otherwise */
  573.     if (v->const_kind == CONST_INT)
  574.         n = INTV(v);
  575.     else if (v->const_kind == CONST_UINT) {
  576.         /* uint ok if can convert to integer*/
  577.         n = int_toi(UINTV(v));
  578.         if (!arith_overflow)
  579.              return n;
  580.         chaos("get_ivalue_int: cannot convert uint");
  581.     }
  582.     else
  583.         chaos("get_ivalue: const not int");
  584.     return n;
  585. }
  586.  
  587. /* Formatted_name */
  588.  
  589. char *formatted_name(char *unit)                    /*;formatted_name*/
  590. {
  591.     char *kind, *unit_kind;
  592.  
  593.     kind = unit_name_type(unit);
  594.     if (is_subunit(unit))        unit_kind = "proper body ";
  595.     else if (streq(kind, "sp"))  unit_kind = "package spec ";
  596.     else if (streq(kind, "bo"))  unit_kind = "package body ";
  597.     else if (streq(kind, "ss"))  unit_kind = "subprogram spec ";
  598.     else if (streq(kind, "su"))  unit_kind = "subprogram ";
  599.     else if (streq(kind, "ma"))  unit_kind = "binding unit ";
  600.     else unit_kind = "unit ";
  601.     return strjoin(unit_kind, unit_name_name(unit));
  602. }
  603.  
  604. /* On expressions */
  605.  
  606. int size_entry(Symbol entry_name)                        /*;size_entry*/
  607. {
  608.     /* Computes the size reserved on the stack for parameters of the entry */
  609.  
  610.     Tuple    formals;
  611.     Symbol    fname, ftype;
  612.     int        fmode;
  613.     int        addr_size, size;
  614.     Fortup    ft1;
  615.  
  616.     formals   = SIGNATURE(entry_name);
  617.     addr_size = su_size(TK_ADDR);
  618.     size         = 0;
  619.     FORTUP(fname = (Symbol), formals, ft1) ;
  620.         fmode = NATURE(fname);
  621.         ftype = TYPE_OF(fname);
  622.         size += addr_size;
  623.  
  624.         /* scalar out and in out parameters takes 2 stacks locations */
  625.         /* one for returned na_out value, the other for temporary na_in; */
  626.         /* Array addresses are mu_dble. */
  627.         if    ((is_simple_type(ftype) && (fmode != na_in))
  628.           || is_array_type(ftype)) {
  629.             size += addr_size;
  630.         }
  631.     ENDFORTUP(ft1);
  632.  
  633.     return size;
  634. }
  635.  
  636. int is_generated_label(Symbol label_name)                 /*;is_generated_label*/
  637. {
  638.     /*
  639.      * This procedure look at the first character of the name of a 
  640.      * label to check if it as been generated by the parser.
  641.      * Note: This is called only once from expand, and it should be
  642.      * acceptable to always return FALSE.
  643.      */
  644.  
  645.     return *(char *)ORIG_NAME(label_name) == '#';
  646. }
  647.  
  648. /* Patch_code */
  649.  
  650. void patch_code(unsigned int location, unsigned int value)        /*;patch_code*/
  651. {
  652.     /*CODE_SEGMENT(location+1) = value;*/
  653.     /* Patch specified location (following one specified) and restore
  654.      * segment position to end
  655.      */
  656.  
  657.     /* move to patch location*/
  658.     segment_set_pos(CODE_SEGMENT, (unsigned) location+1, 0);
  659.     segment_put_word(CODE_SEGMENT, value);
  660.     segment_set_pos(CODE_SEGMENT, 0, 2); /* move to end */
  661. }
  662.  
  663. void patch_code_byte(int location, int value)            /*;patch_code_byte*/
  664. {
  665.     /* The SETL code to patch a full address takes the form
  666.      *    CODE_SEGMENT(patch_addr) = base; -- where base is segment number
  667.      *    patch_code(patch_addr, off); -- where off is offset part of address
  668.      * Note that patch_code patches after specified location.
  669.      * patch_code_byte is defined to correspond to first line in above sequence
  670.      * and patches at the specified location.
  671.      */
  672.  
  673.     segment_set_pos(CODE_SEGMENT, location, 0); /* move to location*/
  674.     segment_put_byte(CODE_SEGMENT, value);
  675.     segment_set_pos(CODE_SEGMENT, 0, 2); /* move to end */
  676. }
  677. /* Update_code */
  678.  
  679. void update_code(int location, int value)                    /*;update_code*/
  680. {
  681.     int oval;        /* TBSL: is this unsigned??*/
  682.     /*CODE_SEGMENT(location+1) -= value;*/
  683.     oval = segment_get_off(CODE_SEGMENT, location+1);
  684.     segment_put_off(CODE_SEGMENT, location+1, oval - value);
  685.     segment_set_pos(CODE_SEGMENT, 0, 2); /* move to end */
  686. }
  687.  
  688. /* Compiler_error */
  689.  
  690. #ifdef DEBUG
  691. void compiler_error(char *reason)                            /*;compiler_error*/
  692. {
  693.     errors++;
  694.     list_hdr(ERR_COMPILER);
  695.     fprintf(MSGFILE, "  %s\n", reason);
  696.     /*PRINTA(GENfile, ERR_COMPILER, ada_line, 0, ada_line, 0, '    '+reason);*/
  697.     if (debug_flag)
  698.         printf("--> %s\n", reason);
  699.     chaos("compiler errror");
  700. }
  701. #endif
  702.  
  703. /* the following included for compatibility with sem sources */
  704. void errmsg(char *msg, char *lrm, Node node)                    /*;errmsg */
  705. {
  706.     user_error(msg);
  707. }
  708.  
  709. #ifdef TRACE
  710.  
  711. /* use gen_trace for one with with trace string. If more than one
  712.  * arg, use suffix to indicte argyment type.
  713.  * _node for node
  714.  * _nodes for tuple of nodes
  715.  * _symbol for symbol
  716.  * _symbols for tuple of symbols
  717.  * _relay for tuple of symbols
  718.  * _i for integer (NOT SUED)
  719.  * _c for comment (string constant) (NOT USED)
  720.  */
  721.  
  722. void gen_trace(char *caller)                                    /*;gen_trace*/
  723. {
  724.     printf("TRACE %s\n", caller);
  725. }
  726.  
  727. void gen_trace_node(char *caller, Node node)                /*;gen_trace_node*/
  728. {
  729.     printf("TRACE %s ", caller);
  730.     zpnod(node);
  731. }
  732.  
  733. void gen_trace_nodes(char *caller, Tuple nodes)            /*;gen_trace_nodes*/
  734. {
  735.  
  736.     Node    n;
  737.     Fortup    ft1;
  738.  
  739.     gen_trace(caller);
  740.     FORTUP(n = (Node), nodes, ft1);
  741.         zpnod(n);
  742.     ENDFORTUP(ft1);
  743. }
  744.  
  745. void gen_trace_symbol(char *caller, Symbol symbol)        /*;gen_trace_symbol*/
  746. {
  747.     printf("TRACE %s ", caller);
  748.     zpsym(symbol);
  749. }
  750.  
  751. void gen_trace_symbols(char *caller, Tuple symbols)        /*;gen_trace_symbols*/
  752. {
  753.  
  754.     Symbol    n;
  755.     Fortup    ft1;
  756.  
  757.     gen_trace(caller);
  758.     FORTUP(n = (Symbol), symbols, ft1);
  759.         zpsym(n);
  760.     ENDFORTUP(ft1);
  761. }
  762.  
  763. void gen_trace_string(char *caller, char *s)            /*;gen_trace_string*/
  764. {
  765.     printf("TRACE %s %s\n", caller, s);
  766. }
  767.  
  768. void gen_trace_strings(char *caller, Tuple strings)        /*;gen_trace_strings*/
  769. {
  770.     char    *s;
  771.     Fortup    ft1;
  772.  
  773.     gen_trace(caller);
  774.     FORTUP(s = (char *), strings, ft1);
  775.         printf("%s\n", s);
  776.     ENDFORTUP(ft1);
  777. }
  778.  
  779. void gen_trace_units(char *caller, Set uset)                /*;gen_trace_units*/
  780. {
  781.     /* uset is set of unit numbers. print their names */
  782.     Forset fs1;
  783.     int unum;
  784.  
  785.     gen_trace(caller);
  786.     FORSET(unum = (int), uset, fs1);
  787.         printf("  %s\n", pUnits[unum]->name);
  788.     ENDFORSET(fs1);
  789. }
  790. #endif
  791.  
  792. void labelmap_put(Symbol sym, int comp, char *val)            /*;labelmap_put*/
  793. {
  794.     Tuple    tup;
  795.  
  796.     /* set label map value for symbol sym, component comp (one of LABEL_STATIC,
  797.      * ...), to value val.
  798.      * using EMAP for labelmap
  799.      */
  800.  
  801.     if (!emap_get(sym))
  802.         tup = labelmap_def(sym);
  803.     else
  804.         tup = EMAP_VALUE;
  805.     if (comp<1 || comp>LABEL_SIZE)
  806.         chaos("labelmap_put label code out of range");
  807.     tup[comp] = val;
  808. }
  809.  
  810. static Tuple labelmap_def(Symbol sym)                        /*;labelmap_def*/
  811. {
  812.     Tuple tup;
  813.  
  814.     tup = tup_new(LABEL_SIZE);
  815.     tup[LABEL_STATIC_DEPTH] = (char *) 0;
  816.     tup[LABEL_POSITION] = (char *) 0;
  817.     tup[LABEL_PATCHES] = (char *) tup_new(0);
  818.     tup[LABEL_EQUAL] = (char *) tup_new(0);
  819.     emap_put(sym, (char *) tup);
  820.     return tup;
  821. }
  822.  
  823. Tuple labelmap_get(Symbol sym)                                /*;labelmap_put*/
  824. {
  825.     /* get label map value for symbol sym, */
  826.  
  827.     Tuple    tup;
  828.  
  829.     if (!emap_get(sym)) { /* creat empty entry if not yet defined */
  830.         tup = labelmap_def(sym);
  831.     }
  832.     else {
  833.         tup = EMAP_VALUE;
  834.     }
  835.     if (tup == (Tuple)0) {
  836. #ifdef DEBUG
  837.         zpsym(sym);
  838. #endif
  839.         chaos("labelmap_get label map is null tuple ");
  840.     }
  841.     return tup;
  842. }
  843.  
  844. Tuple unit_slots_get(int unum)                            /*;unit_slots_get*/
  845. {
  846.     int        n;
  847.  
  848.     n = tup_size(unit_slots);
  849.     if (unum > n)
  850.         chaos("unit_slots_get unit number out of range");
  851.     return (Tuple) unit_slots[unum];
  852. }
  853.  
  854. void unit_slots_put(int unum, Tuple tup)                /*;unit_slots_put*/
  855. {
  856.     int        n, j, k;
  857.     Tuple    ntup;
  858.  
  859.     if (unit_slots == (Tuple)0) { /* if never initialized */
  860.         unit_slots = tup_new(0);
  861.     }
  862.     n = tup_size(unit_slots);
  863.     if (unum>n) { /* if need to allocate new slots */
  864.         unit_slots = tup_exp(unit_slots, unum);
  865.         for (j = n + 1; j <= unum; j++) {
  866.             ntup = tup_new(5);
  867.             for (k = 1; k <= 5; k++)
  868.                 ntup[k] = (char *) tup_new(0);
  869.             unit_slots[j] = (char *) ntup;
  870.         }
  871.     }
  872.     unit_slots[unum] = (char *) tup;
  873. }
  874.  
  875. void user_warning(char *s1, char *s2)                        /*;user_warning*/
  876. {
  877.     list_hdr(ERR_WARNING);
  878.     fprintf(MSGFILE, "%s %s\n", s1, s2);
  879. }
  880.  
  881. int is_generic(char *na)                                    /*;is_generic*/
  882. {
  883.     return tup_memstr(na, late_instances);
  884. }
  885.  
  886. int is_ancestor(char *na)                                    /*;is_ancestor*/
  887. {
  888.     return streq(unit_name_names(na), stub_ancestor(unit_name));
  889. }
  890.  
  891. /* TO_GEN procedures */
  892.  
  893. void list_hdr(int typ)                                            /*;list_hdr*/
  894. {
  895.     fprintf(MSGFILE, "%d %d %d %d %d\t", typ, ada_line, 0, ada_line, 0);
  896. }
  897.  
  898. #ifdef MACHINE_CODE
  899. void to_gen(char *s)                                            /*;to_gen*/
  900. {
  901.     list_hdr(INFORMATION);
  902.     fprintf(MSGFILE, "%s\n", s);
  903. }
  904.  
  905. void to_gen_int(char *s, int n)                                /*;to_gen_int*/
  906. {
  907.     list_hdr(INFORMATION);
  908.     fprintf(MSGFILE, "%s %d\n", s, n);
  909. }
  910.  
  911. void to_gen_unam(char *s1, char *name, char *s2)                /*;to_gen_unam*/
  912. {
  913.     /* corresponds to SETL case of two strings with unit_name between them */
  914.     char    s[250];
  915.     sprintf(s, "%s%s%s", s1, name, s2);
  916.     to_gen(s);
  917. }
  918. #endif
  919.  
  920. void to_list(char *str)                                            /*;to_list*/
  921. {
  922.     fprintf(MSGFILE, "%d 9999 0 9999 0\t", INFORMATION);
  923.     fprintf(MSGFILE, "%s\n", str);
  924. }
  925.